ADA Programming Guide

home *** CD-ROM | disk | FTP | other *** search

/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-tasuti.adb < prev next >

Wrap

Text File | 1996-01-30 | 25KB | 768 lines

------------------------------------------------------------------------------ -- -- -- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . T A S K I N G . U T I L I T I E S -- -- -- -- B o d y -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU Library General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. GNARL is distributed in the hope that it will be use- -- -- ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- -- -- eral Library Public License for more details. You should have received -- -- a copy of the GNU Library General Public License along with GNARL; see -- -- file COPYING.LIB. If not, write to the Free Software Foundation, 675 -- -- Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package provides RTS Internal Declarations. -- These declarations are not part of the GNARLI with System.Task_Primitives; use System.Task_Primitives; with System.Compiler_Exceptions; -- Used for, Tasking_Error_ID with System.Tasking.Abortion; -- Used for, Undefer_Abortion, -- Abort_To_Level with System.Tasking.Queuing; use System.Tasking.Queuing; -- Used for, Queuing.Dequeue_Head with System.Error_Reporting; -- Used for, Error_Reporting.Assert package body System.Tasking.Utilities is ------------------ -- Make_Passive -- ------------------ -- This is a local procedure procedure Make_Passive (T : Utilities.ATCB_Ptr); -- Record that task T is passive. ------------------------------------ -- Vulnerable_Complete_Activation -- ------------------------------------ -- WARNING : Only call this procedure with abortion deferred. -- That's why the name has "Vulnerable" in it. procedure Vulnerable_Complete_Activation (T : ATCB_Ptr; Completed : Boolean) is Activator : ATCB_Ptr; Error : Boolean; begin Activator := T.Activator; if Activator /= null then -- Should only be null for the environment task. -- Decrement the count of tasks to be activated by the -- activator and wake it up so it can check to see if -- all tasks have been activated. Note that the locks -- of the activator and created task are locked here. -- This is necessary because C.Stage and -- T.Activation_Count have to be synchronized. This is -- also done in Activate_Tasks and Init_Abortion. So -- long as the activator lock is always locked first, -- this cannot lead to deadlock. Write_Lock (Activator.L, Error); Write_Lock (T.L, Error); if T.Stage = Can_Activate then T.Stage := Active; Activator.Activation_Count := Activator.Activation_Count - 1; Cond_Signal (Activator.Cond); if Completed then Activator.Exception_To_Raise := Compiler_Exceptions.Tasking_Error_ID; end if; end if; Unlock (T.L); Unlock (Activator.L); end if; end Vulnerable_Complete_Activation; -- PO related routines --------------------- -- Check_Exception -- --------------------- procedure Check_Exception is T : ATCB_Ptr := ID_To_ATCB (Self); Ex : Compiler_Exceptions.Exception_ID := T.Exception_To_Raise; begin T.Exception_To_Raise := Compiler_Exceptions.Null_Exception; Compiler_Exceptions.Raise_Exception (Ex); end Check_Exception; -- Rendezvous related routines ------------------- -- Close_Entries -- ------------------- procedure Close_Entries (Target : Task_ID) is T : ATCB_Ptr := ID_To_ATCB (Target); Temp_Call : Entry_Call_Link; Null_Call : Entry_Call_Link := null; Temp_Caller : ATCB_Ptr; TAS_Result : Boolean; Error : Boolean; begin -- Purging pending callers that are in the middle of rendezvous Temp_Call := T.Call; while Temp_Call /= null loop Temp_Call.Exception_To_Raise := Compiler_Exceptions.Tasking_Error_ID; Temp_Caller := ID_To_ATCB (Temp_Call.Self); -- Problem: Once this lock is unlocked, the target gan go on to -- accept other calls, which will be missed by loop. The question -- is, is there something else that will prevent this??? -- If the target is in an abortion deferred region at this point, -- I don't know what it would be. -- By the time we get here, we do know that the target is complete -- and not callable. Callable is unprotected, but Stage is protected -- by T.L. If all forms of accept made sure under the protection of -- T.L that they were not complete before accepting a call, then it -- should be safe to unlock this here. -- Problem: what about multiple aborters? If two tasks are in this -- routine at once, then there could contention if this mutex is -- unlocked. We need some other form of claim mechanism to prevent -- this. I think that the mechanism outlined in the implementation -- sketch, where an aborter waits for a previous aborter to finish -- its work, might solve this. -- What if T itself is at exactly this point and gets aborted? In -- that case, I think that the aborter has to wait for T to finish -- completing itself. This was previously done by contending for the -- mutex; it might now have to be done with some kind of flag, or -- maybe another stage. Perhaps we are setting Stage=Complete too -- soon, and abortion should wait on that. That would require -- some other flag to claim the right to complete, however. This -- flag could probably be protected by T.L; there should not be -- any need for a TAS or global mutex. Perhaps the Aborting flag -- could do this, though right now all it means is that an abortion -- exception has been sent. We really need a separate Completing -- flag (ugh). On the bright side, this might mean that completion -- can be treated as once-and-once-only, and need not be reentrant. -- Problem: What does an acceptor do when it finds that it is being -- completed? I guess it should wait until completion is finished, -- just like a second aborter. Otherwise, it might continue on -- with a rendezvous that it never really accepted. Write_Lock (Temp_Caller.L, Error); Temp_Call.Done := True; Unlock (Temp_Caller.L); -- The caller can break out of its loop at this point, and never -- notice the abortion. -- Temp_Call.Call_Claimed:= False; -- Wrong, I think. This should look like a completed call to everyone. ??? Abort_To_Level (ATCB_To_ID (Temp_Caller), Temp_Call.Level - 1); -- I think this might be wrong; Abortion takes precedence over -- exceptions in the call block. ??? -- Not true; the last call to be canceled won't raise Abortion again; -- it raises the chosen exception instead. This is true of leaf -- (suspending) calls as well; they decrement the nesting level -- before undeferring abortion, which will prevent further abortion -- (providing that abortion is not to an outer level). -- Final resolution and removal of these comments, or replacement -- by comments saying what is happening without speculation -- is needed (RBKD) ??? Temp_Call := Temp_Call.Acceptor_Prev_Call; end loop; -- Purging entry queues for J in 1 .. T.Entry_Num loop Dequeue_Head (T.Entry_Queues (J), Temp_Call); if Temp_Call /= Null_Call then loop Test_And_Set (Temp_Call.Call_Claimed'Address, TAS_Result); if TAS_Result then Temp_Caller := ID_To_ATCB (Temp_Call.Self); Temp_Call.Exception_To_Raise := Compiler_Exceptions.Tasking_Error_ID; Temp_Call.Done := True; Abort_To_Level ( ATCB_To_ID (Temp_Caller), Temp_Call.Level - 1); else null; -- Someone else claimed this call. It must be to cancel it, -- since the acceptor can't have accepted it at this point. -- So far as we are concerned, this call is not on the -- queue, and we don't have to raise tasking error in the -- caller. end if; Dequeue_Head (T.Entry_Queues (J), Temp_Call); exit when Temp_Call = Null_Call; end loop; end if; end loop; end Close_Entries; ---------------------------- -- Complete_On_Sync_Point -- ---------------------------- procedure Complete_on_Sync_Point (T : Task_ID) is Target : ATCB_Ptr := ID_To_ATCB (T); Call : Entry_Call_Link; TAS_Result : Boolean; Error : Boolean; begin Write_Lock (Target.L, Error); if Target.Suspended_Abortably then if Target.Accepting /= Not_Accepting then Unlock (Target.L); Complete (T); else -- Hopefully suspended on an entry call by elimination. if Target.ATC_Nesting_Level > ATC_Level_Base'First then Call := Target.Entry_Calls (Target.ATC_Nesting_Level)'Access; Test_And_Set (Call.Call_Claimed'Address, TAS_Result); if TAS_Result then Unlock (Target.L); Complete (T); Call.Call_Claimed := False; -- To allow abortion to claim it. else Unlock (Target.L); end if; end if; end if; else Unlock (Target.L); end if; end Complete_on_Sync_Point; -------------------- -- Reset_Priority -- -------------------- procedure Reset_Priority (Acceptor_Prev_Priority : Rendezvous_Priority; Acceptor : Task_ID) is Acceptor_ATCB : ATCB_Ptr := ID_To_ATCB (Acceptor); begin if Acceptor_Prev_Priority /= Priority_Not_Boosted then Acceptor_ATCB.Current_Priority := Acceptor_Prev_Priority; Set_Priority (Acceptor_ATCB.LL_TCB'Access, Acceptor_ATCB.Current_Priority); end if; end Reset_Priority; --------------------------- -- Terminate_Alternative -- --------------------------- -- WARNING : Only call this procedure with abortion deferred. This -- procedure needs to have abortion deferred while it has the current -- task's lock locked. Since it is called from two procedures which -- also need abortion deferred, it is left controlled on entry to -- this procedure. procedure Terminate_Alternative is P, T : ATCB_Ptr := ID_To_ATCB (Self); Taken : Boolean; Error : Boolean; begin Make_Passive (T); -- Note that abortion is deferred here (see WARNING above) Write_Lock (T.L, Error); T.Terminate_Alternative := true; while T.Accepting /= Not_Accepting and then T.Stage /= Complete and then T.Pending_ATC_Level >= T.ATC_Nesting_Level loop Cond_Wait (T.Cond, T.L); end loop; if T.Stage = Complete then Unlock (T.L); if T.Pending_ATC_Level < T.ATC_Nesting_Level then Abortion.Undefer_Abortion; Error_Reporting.Assert (False, "Continuing after being aborted!"); end if; Abort_To_Level (ATCB_To_ID (T), 0); Abortion.Undefer_Abortion; Error_Reporting.Assert (False, "Continuing after being aborted!"); end if; T.Terminate_Alternative := false; Unlock (T.L); end Terminate_Alternative; -------------- -- Complete -- -------------- procedure Complete (Target : Task_ID) is T : ATCB_Ptr := ID_To_ATCB (Target); Caller : ATCB_Ptr := ID_To_ATCB (Self); Task1 : ATCB_Ptr; Task2 : ATCB_Ptr; Error : Boolean; begin -- Make_Passive used to be the last thing done in this routine in the -- original MRTSI code. Make_Passive was modified not to process a -- completed task, so setting the complete flag conflicted with this. -- I don't see any reason why the task cannot be made passive before -- it is marked as completed, but I may find out. ??? Make_Passive (T); Write_Lock (T.L, Error); if T.Stage < Completing then T.Stage := Completing; T.Accepting := Not_Accepting; -- *LATER* consider new value of this type ??? T.Awaited_Dependent_Count := 0; Unlock (T.L); Close_Entries (ATCB_To_ID (T)); T.Stage := Complete; -- Wake up all the pending calls on Aborter_Link list Task1 := T.Aborter_Link; T.Aborter_Link := null; while (Task1 /= null) loop Task2 := Task1; Task1 := Task1.Aborter_Link; Task2.Aborter_Link := null; Cond_Signal (Task2.Cond); end loop; else -- Some other task is completing this task. So just wait until -- the completion is done. A list of such waiting tasks is -- maintained by Aborter_Link in ATCB. while T.Stage < Complete loop if T.Aborter_Link /= null then Caller.Aborter_Link := T.Aborter_Link; end if; T.Aborter_Link := Caller; Cond_Wait (Caller.Cond, T.L); end loop; Unlock (T.L); end if; end Complete; -- Task_Stage related routines ---------------------- -- Make_Independent -- ---------------------- procedure Make_Independent is T : ATCB_Ptr := ID_To_ATCB (Self); P : ATCB_Ptr; Result : Boolean; Error : Boolean; begin Write_Lock (T.L, Error); P := T.Parent; Unlock (T.L); Write_Lock (P.L, Error); Write_Lock (T.L, Error); T.Master_of_Task := Master_ID (0); if P.Awake_Count > 1 then P.Awake_Count := P.Awake_Count - 1; end if; Unlock (T.L); Unlock (P.L); Remove_From_All_Tasks_List (T, Result); Error_Reporting.Assert (Result, "Failed to delete an entry from All_Tasks_List"); end Make_Independent; -- Task Abortion related routines -------------------- -- Abort_To_Level -- -------------------- procedure Abort_To_Level (Target : Task_ID; L : ATC_Level) is T : ATCB_Ptr := ID_To_ATCB (Target); Error : Boolean; begin Write_Lock (T.L, Error); if T.Pending_ATC_Level > L then T.Pending_ATC_Level := L; T.Pending_Action := True; if not T.Aborting then T.Aborting := True; if T.Suspended_Abortably then Cond_Signal (T.Cond); Cond_Signal (T.Rend_Cond); -- Ugly; think about ways to have tasks suspend on one -- condition variable. ??? else if Target = Self then Unlock (T.L); Abort_Task (T.LL_TCB'Access); return; elsif T.Stage /= Terminated then Abort_Task (T.LL_TCB'Access); end if; -- If this task is aborting itself, it should unlock itself -- before calling abort, as it is unlikely to have the -- opportunity to do so afterwords. On the other hand, if -- another task is being aborted, we want to make sure it is -- not terminated, since there is no need to abort a terminated -- task, and it may be illegal if it has stopped executing. -- In this case, the Abort_Task must take place under the -- protection of the mutex, so we know that Stage/=Terminated. end if; end if; end if; Unlock (T.L); end Abort_To_Level; ------------------- -- Abort_Handler -- ------------------- procedure Abort_Handler (Context : Task_Primitives.Pre_Call_State) is T : ATCB_Ptr := ID_To_ATCB (Self); begin if T.Deferral_Level = 0 and then T.Pending_ATC_Level < T.ATC_Nesting_Level then raise Standard'Abort_Signal; -- Not a good idea; signal remains masked after the Abortion ??? -- exception is handled. There are a number of solutions : -- 1. Change the PC to point to code that raises the exception and -- then jumps to the location that was interrupted. -- 2. Longjump to the code that raises the exception. -- 3. Unmask the signal in the Abortion exception handler -- (in the RTS). end if; end Abort_Handler; ---------------------- -- Abort_Dependents -- ---------------------- -- Process abortion of child tasks. -- Abortion should be dererred when calling this routine. -- No mutexes should be locked when calling this routine. procedure Abort_Dependents (Abortee : Task_ID) is Temp_T : ATCB_Ptr; Temp_P : ATCB_Ptr; Old_Pending_ATC_Level : ATC_Level_Base; TAS_Result : Boolean; A : ATCB_Ptr := ID_To_ATCB (Abortee); Error : Boolean; begin Write_Lock (All_Tasks_L, Error); Temp_T := All_Tasks_List; while Temp_T /= null loop Temp_P := Temp_T.Parent; while Temp_P /= null loop exit when Temp_P = A; Temp_P := Temp_P.Parent; end loop; if Temp_P = A then Temp_T.Accepting := Not_Accepting; -- Send cancel signal. Complete_on_Sync_Point (ATCB_To_ID (Temp_T)); Abort_To_Level (ATCB_To_ID (Temp_T), 0); end if; Temp_T := Temp_T.All_Tasks_Link; end loop; Unlock (All_Tasks_L); end Abort_Dependents; ------------------ -- Make_Passive -- ------------------ -- If T is the last dependent of some master in task P to become passive, -- then release P. A special case of this is when T has no dependents -- and is completed. In this case, T itself should be released. -- If the parent is made passive, this is repeated recursively, with C -- being the previous parent and P being the next parent up. -- Note that we have to hold the locks of both P and C (locked in that -- order) so that the Awake_Count of C and the Awaited_Dependent_Count of -- P will be synchronized. Otherwise, an attempt by P to terminate can -- preempt this routine after C's Awake_Count has been decremented to zero -- but before C has checked the Awaited_Dependent_Count of P. P would not -- count C in its Awaited_Dependent_Count since it is not awake, but it -- might count other awake dependents. When C gained control again, it -- would decrement P's Awaited_Dependent_Count to indicate that it is -- passive, even though it was never counted as active. This would cause -- P to wake up before all of its dependents are passive. -- Note : Any task with an interrupt entry should never become passive. -- Support for this feature needs to be added here. procedure Make_Passive (T : Utilities.ATCB_Ptr) is P : Utilities.ATCB_Ptr; -- Task whose Awaited_Dependent_Count may be decremented. C : Utilities.ATCB_Ptr; -- Task whose awake-count gets decremented. H : Utilities.ATCB_Ptr; -- Highest task that is ready to terminate dependents. Taken : Boolean; Activator : Utilities.ATCB_Ptr; Error : Boolean; begin Utilities.Vulnerable_Complete_Activation (T, Completed => False); Write_Lock (T.L, Error); if T.Stage >= Utilities.Passive then Unlock (T.L); return; else T.Stage := Utilities.Passive; Unlock (T.L); end if; H := null; P := T.Parent; C := T; while C /= null loop if P /= null then Write_Lock (P.L, Error); Write_Lock (C.L, Error); C.Awake_Count := C.Awake_Count - 1; if C.Awake_Count /= 0 then -- C is not passive; we cannot make anything above this point -- passive. Unlock (C.L); Unlock (P.L); exit; end if; if P.Awaited_Dependent_Count /= 0 then -- We have hit a non-task master; we will not be able to make -- anything above this point passive. P.Awake_Count := P.Awake_Count - 1; if C.Master_of_Task = P.Master_Within then P.Awaited_Dependent_Count := P.Awaited_Dependent_Count - 1; if P.Awaited_Dependent_Count = 0 then H := P; end if; end if; Unlock (C.L); Unlock (P.L); exit; end if; if C.Stage = Utilities.Complete then -- C is both passive (Awake_Count = 0) and complete; wake it -- up to await termination of its dependents. It will not be -- complete if it is waiting on a terminate alternative. Such -- a task is not ready to wait for its dependents to terminate, -- though one of its ancestors may be. H := C; end if; Unlock (C.L); Unlock (P.L); C := P; P := C.Parent; else Write_Lock (C.L, Error); C.Awake_Count := C.Awake_Count - 1; if C.Awake_Count /= 0 then -- C is not passive; we cannot make anything above -- this point passive. Unlock (C.L); exit; end if; if C.Stage = Utilities.Complete then -- C is both passive (Awake_Count = 0) and complete; wake it -- up to await termination of its dependents. It will not be -- complete if it is waiting on a terminate alternative. Such -- a task is not ready to wait for its dependents to terminate, -- though one of its ancestors may be. H := C; end if; Unlock (C.L); C := P; end if; end loop; if H /= null then Cond_Signal (H.Cond); end if; end Make_Passive; procedure Remove_From_All_Tasks_List ( Source : Utilities.ATCB_Ptr; Result : out Boolean) is C : Utilities.ATCB_Ptr; P : Utilities.ATCB_Ptr; Previous : Utilities.ATCB_Ptr; Error : Boolean; begin Write_Lock (Utilities.All_Tasks_L, Error); Result := False; Previous := null; C := Utilities.All_Tasks_List; while C /= null loop if C = Source then Result := True; if Previous = null then Utilities.All_Tasks_List := Utilities.All_Tasks_List.All_Tasks_Link; else Previous.All_Tasks_Link := C.All_Tasks_Link; end if; exit; end if; Previous := C; C := C.All_Tasks_Link; end loop; Unlock (Utilities.All_Tasks_L); end Remove_From_All_Tasks_List; end System.Tasking.Utilities;